home *** CD-ROM | disk | FTP | other *** search
/ Amiga Plus 2000 #5 / Amiga Plus CD - 2000 - No. 5.iso / Tools / Dev / fpc / inc / text.inc < prev    next >
Encoding:
Text File  |  1998-10-28  |  28.0 KB  |  1,263 lines
  1. {
  2.     $Id: text.inc,v 1.21 1998/08/17 22:42:17 michael Exp $
  3.     This file is part of the Free Pascal Run time library.
  4.     Copyright (c) 1993,97 by the Free Pascal development team
  5.  
  6.     See the file COPYING.FPC, included in this distribution,
  7.     for details about the copyright.
  8.  
  9.     This program is distributed in the hope that it will be useful,
  10.     but WITHOUT ANY WARRANTY; without even the implied warranty of
  11.     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
  12.  
  13.  **********************************************************************}
  14.  
  15. {
  16.   Possible Defines:
  17.  
  18.   EXTENDED_EOF    Use extended EOF checking for textfile, necessary for
  19.                   Pipes and Sockets under Linux
  20.   EOF_CTRLZ       Is Ctrl-Z (#26) a EOF mark for textfiles
  21.   SHORT_LINEBREAK Use short Linebreaks #10 instead of #10#13
  22.  
  23.   Both EXTENDED_EOF and SHORT_LINEBREAK are defined in the Linux system
  24.   unit (syslinux.pp)
  25. }
  26.  
  27. {****************************************************************************
  28.                     subroutines For TextFile handling
  29. ****************************************************************************}
  30.  
  31.  
  32. Procedure FileCloseFunc(Var t:TextRec);
  33. Begin
  34.   Do_Close(t.Handle);
  35.   t.Handle:=UnusedHandle;
  36. End;
  37.  
  38.  
  39. Procedure FileReadFunc(var t:TextRec);
  40. Begin
  41.   t.BufEnd:=Do_Read(t.Handle,Longint(t.Bufptr),t.BufSize);
  42.   t.BufPos:=0;
  43. End;
  44.  
  45.  
  46. Procedure FileWriteFunc(var t:TextRec);
  47. Begin
  48.   Do_Write(t.Handle,Longint(t.Bufptr),t.BufPos);
  49.   t.BufPos:=0;
  50. End;
  51.  
  52.  
  53.  
  54. Procedure FileOpenFunc(var t:TextRec);
  55. var
  56.   Flags : Longint;
  57. Begin
  58.   Case t.mode Of
  59.     fmInput : Flags:=$1000;
  60.    fmOutput : Flags:=$1101;
  61.    fmAppend : Flags:=$1011;
  62.   else
  63.    HandleError(102);
  64.   End;
  65.   Do_Open(t,PChar(@t.Name),Flags);
  66.   t.CloseFunc:=@FileCloseFunc;
  67.   t.FlushFunc:=nil;
  68.   if t.Mode=fmInput then
  69.    t.InOutFunc:=@FileReadFunc
  70.   else
  71.    begin
  72.      t.InOutFunc:=@FileWriteFunc;
  73.    { Only install flushing if its a NOT a file }
  74.      if Do_Isdevice(t.Handle) then
  75.       t.FlushFunc:=@FileWriteFunc;
  76.    end;
  77. End;
  78.  
  79.  
  80. Procedure assign(var t:Text;const s:String);
  81. Begin
  82.   FillChar(t,SizEof(TextRec),0);
  83. { only set things that are not zero }
  84.   TextRec(t).Handle:=UnusedHandle;
  85.   TextRec(t).mode:=fmClosed;
  86.   TextRec(t).BufSize:=128;
  87.   TextRec(t).Bufptr:=@TextRec(t).Buffer;
  88.   TextRec(t).OpenFunc:=@FileOpenFunc;
  89.   Move(s[1],TextRec(t).Name,Length(s));
  90. End;
  91.  
  92.  
  93. Procedure assign(var t:Text;p:pchar);
  94. begin
  95.   Assign(t,StrPas(p));
  96. end;
  97.  
  98.  
  99. Procedure assign(var t:Text;c:char);
  100. begin
  101.   Assign(t,string(c));
  102. end;
  103.  
  104.  
  105. Procedure Close(var t : Text);[Public,Alias: 'CLOSE_TEXT',IOCheck];
  106. Begin
  107.   if InOutRes <> 0 then Exit;
  108.   If (TextRec(t).mode<>fmClosed) Then
  109.    Begin
  110.    { Write pending buffer }
  111.      If Textrec(t).Mode=fmoutput then
  112.        FileFunc(TextRec(t).InOutFunc)(TextRec(t));
  113.      TextRec(t).mode:=fmClosed;
  114.    { Only close functions not connected to stdout.}
  115.      If ((TextRec(t).Handle<>StdInputHandle) or
  116.          (TextRec(t).Handle<>StdOutputHandle) or
  117.          (TextRec(t).Handle<>StdErrorHandle)) Then
  118.       FileFunc(TextRec(t).CloseFunc)(TextRec(t));
  119.    End;
  120. End;
  121.  
  122.  
  123. Procedure OpenText(var t : Text;mode,defHdl:Longint);
  124. Begin
  125.   Case TextRec(t).mode Of {This gives the fastest code}
  126.    fmInput,fmOutput,fmInOut : Close(t);
  127.    fmClosed : ;
  128.   else
  129.    Begin
  130.      InOutRes:=102;
  131.      exit;
  132.    End;
  133.   End;
  134.   TextRec(t).mode:=word(mode);
  135.   FileFunc(TextRec(t).OpenFunc)(TextRec(t))
  136. End;
  137.  
  138.  
  139. Procedure Rewrite(var t : Text);[IOCheck];
  140. Begin
  141.   If InOutRes <> 0 then exit;
  142.   OpenText(t,fmOutput,1);
  143. End;
  144.  
  145.  
  146. Procedure Reset(var t : Text);[IOCheck];
  147. Begin
  148.   If InOutRes <> 0 then exit;
  149.   OpenText(t,fmInput,0);
  150. End;
  151.  
  152.  
  153. Procedure Append(var t : Text);[IOCheck];
  154. Begin
  155.   If InOutRes <> 0 then exit;
  156.   OpenText(t,fmAppend,1);
  157. End;
  158.  
  159.  
  160. Procedure Flush(var t : Text);[IOCheck];
  161. Begin
  162.   If InOutRes <> 0 then exit;
  163.   If TextRec(t).mode<>fmOutput Then
  164.    exit;
  165. { Not the flushfunc but the inoutfunc should be used, becuase that
  166.   writes the data, flushfunc doesn't need to be assigned }
  167.   FileFunc(TextRec(t).InOutFunc)(TextRec(t));
  168. End;
  169.  
  170.  
  171. Procedure Erase(var t:Text);[IOCheck];
  172. Begin
  173.   If InOutRes <> 0 then exit;
  174.   If TextRec(t).mode=fmClosed Then
  175.    Do_Erase(PChar(@TextRec(t).Name));
  176. End;
  177.  
  178.  
  179. Procedure Rename(var t : text;p:pchar);[IOCheck];
  180. Begin
  181.   If InOutRes <> 0 then exit;
  182.   If TextRec(t).mode=fmClosed Then
  183.    Begin
  184.      Do_Rename(PChar(@TextRec(t).Name),p);
  185.      Move(p^,TextRec(t).Name,StrLen(p)+1);
  186.    End;
  187. End;
  188.  
  189.  
  190. Procedure Rename(var t : Text;const s : string);[IOCheck];
  191. var
  192.   p : array[0..255] Of Char;
  193. Begin
  194.   If InOutRes <> 0 then exit;
  195.   Move(s[1],p,Length(s));
  196.   p[Length(s)]:=#0;
  197.   Rename(t,Pchar(@p));
  198. End;
  199.  
  200.  
  201. Procedure Rename(var t : Text;c : char);[IOCheck];
  202. var
  203.   p : array[0..1] Of Char;
  204. Begin
  205.   If InOutRes <> 0 then exit;
  206.   p[0]:=c;
  207.   p[1]:=#0;
  208.   Rename(t,Pchar(@p));
  209. End;
  210.  
  211.  
  212. Function Eof(Var t: Text): Boolean;[IOCheck];
  213. Begin
  214.   If InOutRes <> 0 then exit;
  215. {$IFNDEF EXTENDED_EOF}
  216.   {$IFDEF EOF_CTRLZ}
  217.     Eof:=TextRec(t).Buffer[TextRec(t).BufPos]=#26;
  218.     If Eof Then
  219.      Exit;
  220.   {$ENDIF EOL_CTRLZ}
  221.   Eof:=(Do_FileSize(TextRec(t).Handle)<=Do_FilePos(TextRec(t).Handle));
  222.   If Eof Then
  223.    Eof:=TextRec(t).BufEnd <= TextRec(t).BufPos;
  224. {$ELSE EXTENDED_EOF}
  225.   { The previous method will NOT work on stdin and pipes or sockets.
  226.     So how to do it ?
  227.      1) Check if characters in buffer - Yes ? Eof=false;
  228.      2) Read buffer full. If 0 Chars Read : Eof !
  229.     Michael.}
  230.   If TextRec(T).mode=fmClosed Then  { Sanity Check }
  231.    Begin
  232.      Eof:=True;
  233.      Exit;
  234.    End;
  235.   If (TextRec(T).BufPos < TextRec(T).BufEnd) Then
  236.    Begin
  237.      Eof:=False;
  238.      Exit
  239.    End;
  240.   TextRec(T).BufPos:=0;
  241.   TextRec(T).BufEnd:=Do_Read(TextRec(T).Handle,Longint(TextRec(T).BufPtr),TextRec(T).BufSize);
  242.   If TextRec(T).BufEnd<0 Then
  243.    TextRec(T).BufEnd:=0;
  244.   Eof:=(TextRec(T).BufEnd=0);
  245. {$ENDIF EXTENDED_EOF}
  246. End;
  247.  
  248.  
  249. Function Eof:Boolean;
  250. Begin
  251.   Eof:=Eof(Input);
  252. End;
  253.  
  254.  
  255. Function SeekEof (Var F : Text) : Boolean;
  256. Var
  257.   TR   : ^TextRec;
  258.   Temp : Longint;
  259. Begin
  260.   TR:=@TextRec(f);
  261.   If TR^.mode<>fmInput Then exit (true);
  262.   SeekEof:=True;
  263.   {No data in buffer ? Fill it }
  264.   If TR^.BufPos>=TR^.BufEnd Then
  265.    FileFunc(TR^.InOutFunc)(TR^);
  266.  
  267.   Temp:=TR^.BufPos;
  268.   while (TR^.BufPos<TR^.BufEnd) Do
  269.    Begin
  270.      If (TR^.Bufptr^[Temp] In [#9,#10,#13,' ']) Then
  271.       Inc(Temp)
  272.      else
  273.       Begin
  274.         SeekEof:=False;
  275.         TR^.BufPos:=Temp;
  276.         exit;
  277.       End;
  278.      If Temp>=TR^.BufEnd Then
  279.       Begin
  280.         FileFunc(TR^.InOutFunc)(TR^);
  281.         Temp:=TR^.BufPos+1;
  282.       End;
  283.    End;
  284. End;
  285.  
  286.  
  287. Function SeekEof : Boolean;
  288. Begin
  289.   SeekEof:=SeekEof(Input);
  290. End;
  291.  
  292.  
  293. Function Eoln(var t:Text) : Boolean;
  294. Begin
  295. { maybe we need new data }
  296.   If TextRec(t).BufPos>=TextRec(t).BufEnd Then
  297.    FileFunc(TextRec(t).InOutFunc)(TextRec(t));
  298.   Eoln:=Eof(t) or (TextRec(t).Bufptr^[TextRec(t).BufPos] In [#10,#13]);
  299. End;
  300.  
  301.  
  302. Function Eoln : Boolean;
  303. Begin
  304.   Eoln:=Eoln(Input);
  305. End;
  306.  
  307.  
  308. Function SeekEoln (Var F : Text) : Boolean;
  309. Var
  310.   TR   : ^TextRec;
  311.   Temp : Longint;
  312. Begin
  313.   TR:=@TextRec(f);
  314.   If TR^.mode<>fmInput Then
  315.    exit (true);
  316.   SeekEoln:=True;
  317.   {No data in buffer ? Fill it }
  318.   If TR^.BufPos>=TR^.BufEnd Then
  319.    FileFunc(TR^.InOutFunc)(TR^);
  320.   Temp:=TR^.BufPos;
  321.   while (TR^.BufPos<TR^.BufEnd) Do
  322.    Begin
  323.      Case (TR^.Bufptr^[Temp]) Of
  324.       #10 : Exit;
  325.    #9,' ' : Inc(Temp)
  326.      else
  327.       Begin
  328.         SeekEoln:=False;
  329.         TR^.BufPos:=Temp;
  330.         exit;
  331.       End;
  332.      End;
  333.      If Temp>=TR^.BufEnd Then
  334.       Begin
  335.         FileFunc(TR^.InOutFunc)(TR^);
  336.         Temp:=TR^.BufPos+1;
  337.       End;
  338.    End;
  339. End;
  340.  
  341.  
  342. Function SeekEoln : Boolean;
  343. Begin
  344.   SeekEoln:=SeekEoln(Input);
  345. End;
  346.  
  347.  
  348. Procedure SetTextBuf(Var F : Text; Var Buf);[INTERNPROC: In_settextbuf_file_x];
  349.  
  350.  
  351. Procedure SetTextBuf(Var F : Text; Var Buf; Size : Word);
  352. Begin
  353.   TextRec(f).BufPtr:=@Buf;
  354.   TextRec(f).BufSize:=Size;
  355.   TextRec(f).BufPos:=0;
  356.   TextRec(f).BufEnd:=0;
  357. End;
  358.  
  359.  
  360. {*****************************************************************************
  361.                                Write(Ln)
  362. *****************************************************************************}
  363.  
  364. Procedure WriteBuffer(var f:TextRec;var b;len:longint);
  365. var
  366.   p   : pchar;
  367.   left,
  368.   idx : longint;
  369. begin
  370.   p:=pchar(@b);
  371.   idx:=0;
  372.   left:=f.BufSize-f.BufPos;
  373.   while len>left do
  374.    begin
  375.      move(p[idx],f.Bufptr^[f.BufPos],left);
  376.      dec(len,left);
  377.      inc(idx,left);
  378.      inc(f.BufPos,left);
  379.      FileFunc(f.InOutFunc)(f);
  380.      left:=f.BufSize-f.BufPos;
  381.    end;
  382.   move(p[idx],f.Bufptr^[f.BufPos],len);
  383.   inc(f.BufPos,len);
  384. end;
  385.  
  386.  
  387. Procedure WriteBlanks(var f:TextRec;len:longint);
  388. var
  389.   left : longint;
  390. begin
  391.   left:=f.BufSize-f.BufPos;
  392.   while len>left do
  393.    begin
  394.      FillChar(f.Bufptr^[f.BufPos],left,' ');
  395.      dec(len,left);
  396.      inc(f.BufPos,left);
  397.      FileFunc(f.InOutFunc)(f);
  398.      left:=f.BufSize-f.BufPos;
  399.    end;
  400.   FillChar(f.Bufptr^[f.BufPos],len,' ');
  401.   inc(f.BufPos,len);
  402. end;
  403.  
  404.  
  405. Procedure Write_End(var f:TextRec);[Public,Alias:'WRITE_END'];
  406. begin
  407.   if f.FlushFunc<>nil then
  408.    FileFunc(f.FlushFunc)(f);
  409. end;
  410.  
  411.  
  412. Procedure Writeln_End(var f:TextRec);[Public,Alias:'WRITELN_END'];
  413. const
  414. {$IFDEF SHORT_LINEBREAK}
  415.   eollen=1;
  416.   eol : array[0..0] of char=(#10);
  417. {$ELSE SHORT_LINEBREAK}
  418.   eollen=2;
  419.   eol : array[0..1] of char=(#13,#10);
  420. {$ENDIF SHORT_LINEBREAK}
  421. begin
  422.   If InOutRes <> 0 then exit;
  423. { Write EOL }
  424.   WriteBuffer(f,eol,eollen);
  425. { Flush }
  426.   if f.FlushFunc<>nil then
  427.    FileFunc(f.FlushFunc)(f);
  428. end;
  429.  
  430.  
  431. Procedure Write_Str(Len : Longint;var f : TextRec;const s : String);[Public,Alias: 'WRITE_TEXT_STRING'];
  432. Begin
  433.   If InOutRes <> 0 then exit;
  434.   If f.mode<>fmOutput Then
  435.    exit;
  436.   If Len>Length(s) Then
  437.    WriteBlanks(f,Len-Length(s));
  438.   WriteBuffer(f,s[1],Length(s));
  439. End;
  440.  
  441.  
  442. Type
  443.    array00 = array[0..0] Of Char;
  444. Procedure Write_Array(Len : Longint;var f : TextRec;const p : array00);[Public,Alias: 'WRITE_TEXT_PCHAR_AS_ARRAY'];
  445. var
  446.   ArrayLen : longint;
  447. Begin
  448.   If InOutRes <> 0 then exit;
  449.   If f.mode<>fmOutput Then
  450.    exit;
  451.   ArrayLen:=StrLen(p);
  452.   If Len>ArrayLen Then
  453.    WriteBlanks(f,Len-ArrayLen);
  454.   WriteBuffer(f,p,ArrayLen);
  455. End;
  456.  
  457.  
  458. Procedure Write_PChar(Len : Longint;var f : TextRec;p : PChar);[Public,Alias: 'WRITE_TEXT_PCHAR_AS_POINTER'];
  459. var
  460.   PCharLen : longint;
  461. Begin
  462.   If InOutRes <> 0 then exit;
  463.   If f.mode<>fmOutput Then
  464.    exit;
  465.   PCharLen:=StrLen(p);
  466.   If Len>PCharLen Then
  467.    WriteBlanks(f,Len-PCharLen);
  468.   WriteBuffer(f,p^,PCharLen);
  469. End;
  470.  
  471. {$ifdef UseAnsiStrings}
  472. Procedure Write_Text_AnsiString (Len : Longint; Var T : TextRec; Var S : AnsiString);[Public, alias: 'WRITE_TEXT_ANSISTRING'];
  473. {
  474.  Writes a AnsiString to the Text file T
  475. }
  476.  
  477. Var Temp : Pointer;
  478.  
  479. begin
  480.   Temp:=Pointer(S);
  481.   If Temp=Nil then exit;
  482.   Write_pchar (Len,t,PChar(Temp));
  483. end;
  484.  
  485. {$endif}
  486.  
  487.  
  488. Procedure Write_LongInt(Len : Longint;var t : TextRec;l : Longint);[Public,Alias: 'WRITE_TEXT_LONGINT'];
  489. var
  490.   s : String;
  491. Begin
  492.   If InOutRes <> 0 then exit;
  493.   Str(l,s);
  494.   Write_Str(Len,t,s);
  495. End;
  496.  
  497.  
  498. Procedure Write_Real(fixkomma,Len : Longint;var t : TextRec;r : real);[Public,Alias: 'WRITE_TEXT_REAL'];
  499. var
  500.    s : String;
  501. Begin
  502.   If InOutRes <> 0 then exit;
  503. {$ifdef i386}
  504.    Str_real(Len,fixkomma,r,rt_s64real,s);
  505. {$else}
  506.    Str_real(Len,fixkomma,r,rt_s32real,s);
  507. {$endif}
  508.    Write_Str(Len,t,s);
  509. End;
  510.  
  511.  
  512. Procedure Write_Cardinal(Len : Longint;var t : TextRec;l : cardinal);[Public,Alias: 'WRITE_TEXT_CARDINAL'];
  513. var
  514.   s : String;
  515. Begin
  516.   If InOutRes <> 0 then exit;
  517.   Str(L,s);
  518.   Write_Str(Len,t,s);
  519. End;
  520.  
  521. {$ifdef SUPPORT_SINGLE}
  522. Procedure Write_Single(fixkomma,Len : Longint;var t : TextRec;r : single);[Public,Alias: 'WRITE_TEXT_SINGLE'];
  523. var
  524.   s : String;
  525. Begin
  526.   If InOutRes <> 0 then exit;
  527.   Str_real(Len,fixkomma,r,rt_s32real,s);
  528.   Write_Str(Len,t,s);
  529. End;
  530. {$endif SUPPORT_SINGLE}
  531.  
  532.  
  533. {$ifdef SUPPORT_EXTENDED}
  534. Procedure Write_Extended(fixkomma,Len : Longint;var t : TextRec;r : extended);[Public,Alias: 'WRITE_TEXT_EXTENDED'];
  535. var
  536.   s : String;
  537. Begin
  538.   If InOutRes <> 0 then exit;
  539.   Str_real(Len,fixkomma,r,rt_s80real,s);
  540.   Write_Str(Len,t,s);
  541. End;
  542. {$endif SUPPORT_EXTENDED}
  543.  
  544.  
  545. {$ifdef SUPPORT_COMP}
  546. Procedure Write_Comp(fixkomma,Len : Longint;var t : TextRec;r : comp);[Public,Alias: 'WRITE_TEXT_COMP'];
  547. var
  548.   s : String;
  549. Begin
  550.   If InOutRes <> 0 then exit;
  551.   Str_real(Len,fixkomma,r,rt_s64bit,s);
  552.   Write_Str(Len,t,s);
  553. End;
  554. {$endif SUPPORT_COMP}
  555.  
  556.  
  557. {$ifdef SUPPORT_FIXED}
  558. Procedure Write_Fixed(fixkomma,Len : Longint;var t : TextRec;r : fixed);[Public,Alias: 'WRITE_TEXT_FIXED'];
  559. var
  560.   s : String;
  561. Begin
  562.   If InOutRes <> 0 then exit;
  563.   Str_real(Len,fixkomma,r,rt_f32bit,s);
  564.   Write_Str(Len,t,s);
  565. End;
  566. {$endif SUPPORT_FIXED}
  567.  
  568.  
  569. Procedure Write_Boolean(Len : Longint;var t : TextRec;b : Boolean);[Public,Alias: 'WRITE_TEXT_BOOLEAN'];
  570. Begin
  571.   If InOutRes <> 0 then exit;
  572. { Can't use array[boolean] because b can be >0 ! }
  573.   if b then
  574.     Write_Str(Len,t,'TRUE')
  575.   else
  576.     Write_Str(Len,t,'FALSE');
  577. End;
  578.  
  579.  
  580. Procedure Write_Char(Len : Longint;var t : TextRec;c : Char);[Public,Alias: 'WRITE_TEXT_CHAR'];
  581. Begin
  582.   If InOutRes <> 0 then exit;
  583.   If t.mode<>fmOutput Then
  584.    exit;
  585.   If Len>1 Then
  586.    WriteBlanks(t,Len-1);
  587.   If t.BufPos+1>=t.BufSize Then
  588.    FileFunc(t.InOutFunc)(t);
  589.   t.Bufptr^[t.BufPos]:=c;
  590.   Inc(t.BufPos);
  591. End;
  592.  
  593.  
  594. {$ifdef VER0_99_5}
  595. Procedure w(var t : TextRec);[Public,Alias: 'WRITELN_TEXT'];
  596. var
  597.   hs : String;
  598. Begin
  599.   If InOutRes <> 0 then exit;
  600.   {$IFDEF SHORT_LINEBREAK}
  601.    hs:=#10;
  602.   {$ELSE}
  603.    hs:=#13#10;
  604.   {$ENDIF}
  605.   Write_Str(0,t,hs);
  606. End;
  607. {$endif VER0_99_5}
  608.  
  609.  
  610. {*****************************************************************************
  611.                                 Read(Ln)
  612. *****************************************************************************}
  613.  
  614. Function OpenInput(var f:TextRec):boolean;
  615. begin
  616.   If f.mode=fmInput Then
  617.    begin
  618.    { No characters in the buffer? Load them ! }
  619.      If f.BufPos>=f.BufEnd Then
  620.       FileFunc(f.InOutFunc)(f);
  621.      OpenInput:=true;
  622.    end
  623.   else
  624.    OpenInput:=false;
  625. end;
  626.  
  627.  
  628.  
  629. Function NextChar(var f:TextRec;var s:string):Boolean;
  630. begin
  631.   if f.BufPos<f.BufEnd then
  632.    begin
  633.      s:=s+f.BufPtr^[f.BufPos];
  634.      Inc(f.BufPos);
  635.      If f.BufPos>=f.BufEnd Then
  636.       FileFunc(f.InOutFunc)(f);
  637.      NextChar:=true;
  638.    end
  639.   else
  640.    NextChar:=false;
  641. end;
  642.  
  643.  
  644.  
  645. Function IgnoreSpaces(var f:TextRec):Boolean;
  646. {
  647.   Removes all leading spaces,tab,eols from the input buffer, returns true if
  648.   the buffer is empty
  649. }
  650. var
  651.   s : string;
  652. begin
  653.   s:='';
  654.   IgnoreSpaces:=false;
  655.   while f.Bufptr^[f.BufPos] in [#9,#10,#13,' '] do
  656.    if not NextChar(f,s) then
  657.     exit;
  658.   IgnoreSpaces:=true;
  659. end;
  660.  
  661.  
  662. Function ReadSign(var f:TextRec;var s:string):Boolean;
  663. {
  664.   Read + and - sign, return true if buffer is empty
  665. }
  666. begin
  667.   ReadSign:=(not (f.Bufptr^[f.BufPos] in ['-','+'])) or NextChar(f,s);
  668. end;
  669.  
  670.  
  671. Function ReadBase(var f:TextRec;var s:string;var Base:longint):boolean;
  672. {
  673.   Read the base $ For 16 and % For 2, if buffer is empty return true
  674. }
  675. begin
  676.   case f.BufPtr^[f.BufPos] of
  677.    '$' : Base:=16;
  678.    '%' : Base:=2;
  679.   else
  680.    Base:=10;
  681.   end;
  682.   ReadBase:=(Base=10) or NextChar(f,s);
  683. end;
  684.  
  685.  
  686. Function ReadNumeric(var f:TextRec;var s:string;base:longint):Boolean;
  687. {
  688.   Read numeric input, if buffer is empty then return True
  689. }
  690. var
  691.   c : char;
  692. begin
  693.   ReadNumeric:=false;
  694.   c:=f.BufPtr^[f.BufPos];
  695.   while ((base>=10) and (c in ['0'..'9'])) or
  696.         ((base=16) and (c in ['A'..'F','a'..'f'])) or
  697.         ((base=2) and (c in ['0'..'1'])) do
  698.    begin
  699.      if not NextChar(f,s) then
  700.       exit;
  701.      c:=f.BufPtr^[f.BufPos];
  702.    end;
  703.   ReadNumeric:=true;
  704. end;
  705.  
  706.  
  707. Procedure Read_End(var f:TextRec);[Public,Alias:'READ_END'];
  708. begin
  709.   if f.FlushFunc<>nil then
  710.    FileFunc(f.FlushFunc)(f);
  711. end;
  712.  
  713.  
  714. Procedure ReadLn_End(var f : TextRec);[Public,Alias: 'READLN_END'];
  715. Begin
  716.   If InOutRes <> 0 then exit;
  717.   if not OpenInput(f) then
  718.    exit;
  719. { Read until a linebreak }
  720.   while (f.BufPos<f.BufEnd) do
  721.    begin
  722.      inc(f.BufPos);
  723.      if (f.BufPtr^[f.BufPos-1]=#10) then
  724.       exit;
  725.      If f.BufPos>=f.BufEnd Then
  726.       FileFunc(f.InOutFunc)(f);
  727.    end;
  728. { Flush if set }
  729.   if f.FlushFunc<>nil then
  730.    FileFunc(f.FlushFunc)(f);
  731. End;
  732.  
  733.  
  734. {$ifdef VER0_99_5}
  735. Procedure Read_String(var f : TextRec;var s : String);[Public,Alias: 'READ_TEXT_STRING'];
  736. var
  737.   Temp,sPos : Word;
  738. Begin
  739.   { Delete the string }
  740.   s:='';
  741.   If InOutRes <> 0 then exit;
  742.   if not OpenInput(f) then
  743.    exit;
  744.   Temp:=f.BufPos;
  745.   sPos:=1;
  746.   while (f.BufPos<f.BufEnd) and (f.Bufptr^[Temp]<>#10) Do
  747.    Begin
  748.    { search linefeed }
  749.      while (f.Bufptr^[Temp]<>#10) and (Temp<f.BufEnd) Do
  750.       Inc(Temp);
  751.    { copy String. Take 255 char limit in account.}
  752.      If sPos+Temp-f.BufPos<=255 Then
  753.       Begin
  754.         Move (f.Bufptr^[f.BufPos],s[sPos],Temp-f.BufPos);
  755.         sPos:=sPos+Temp-f.BufPos;
  756.       { Remove #13 from a #13#10 break }
  757.         If s[sPos-1]=#13 Then
  758.          dec(sPos);
  759.       End
  760.      else
  761.       Begin
  762.         If (sPos<=255) Then
  763.          Move(f.Bufptr^[f.BufPos],s[sPos],256-sPos);
  764.         sPos:=256
  765.       End;
  766.    { update f.BufPos }
  767.      f.BufPos:=Temp;
  768.      If Temp>=f.BufEnd Then
  769.       Begin
  770.         FileFunc(f.InOutFunc)(f);
  771.         Temp:=f.BufPos;
  772.       End
  773.    End;
  774.   s[0]:=chr(sPos-1);
  775. End;
  776.  
  777. {$else VER0_99_5}
  778.  
  779. Procedure Read_String(Maxlen : Longint;var f : TextRec;var s : String);[Public,Alias:'READ_TEXT_STRING'];
  780. var
  781.   Temp,sPos,nrread : Word;
  782. Begin
  783.   { Delete the string }
  784.   s:='';
  785.   If InOutRes <> 0 then exit;
  786.   if not OpenInput(f) then
  787.    exit;
  788.   Temp:=f.BufPos;
  789.   sPos:=1;
  790.   NrRead:=0;
  791.   while (f.BufPos<f.BufEnd) and ((f.Bufptr^[Temp]<>#10) and (NrRead<Maxlen)) Do
  792.    Begin
  793.    { search linefeed or length of string }
  794.      while ((f.Bufptr^[Temp]<>#10) and (NrRead<Maxlen)) and (Temp<f.BufEnd) Do
  795.       begin
  796.       Temp:=Temp+1;
  797.       NrRead:=NrRead+1;
  798.       end;
  799.    { copy String. Take 255 char limit in account.}
  800.      If sPos+Temp-f.BufPos<=255 Then
  801.       Begin
  802.         Move (f.Bufptr^[f.BufPos],s[sPos],Temp-f.BufPos);
  803.         sPos:=sPos+Temp-f.BufPos;
  804.       { Remove #13 from a #13#10 break }
  805.         If s[sPos-1]=#13 Then
  806.          dec(sPos);
  807.       End
  808.      else
  809.       Begin
  810.         If (sPos<=255) Then
  811.          Move(f.Bufptr^[f.BufPos],s[sPos],256-sPos);
  812.         sPos:=256
  813.       End;
  814.    { update f.BufPos }
  815.      f.BufPos:=Temp;
  816.      If Temp>=f.BufEnd Then
  817.       Begin
  818.         FileFunc(f.InOutFunc)(f);
  819.         Temp:=f.BufPos;
  820.       End
  821.    End;
  822.   s[0]:=chr(sPos-1);
  823. End;
  824. {$endif VER0_99_5}
  825.  
  826.  
  827. Procedure Read_Char(var f : TextRec;var c : Char);[Public,Alias: 'READ_TEXT_CHAR'];
  828. Begin
  829.   c:=#0;
  830.   If InOutRes <> 0 then exit;
  831.   if not OpenInput(f) then
  832.    exit;
  833.   If f.BufPos>=f.BufEnd Then
  834.    c:=#26
  835.   else
  836.    c:=f.Bufptr^[f.BufPos];
  837.   Inc(f.BufPos);
  838. End;
  839.  
  840.  
  841. Procedure Read_PChar(var f : TextRec;var s : PChar);[Public,Alias:'READ_TEXT_PCHAR_AS_POINTER'];
  842. var
  843.   p    : PChar;
  844.   Temp : byte;
  845. Begin
  846. { Delete the string }
  847.   s^:=#0;
  848.   If InOutRes <> 0 then exit;
  849.   p:=s;
  850.   if not OpenInput(f) then
  851.    exit;
  852.   Temp:=f.BufPos;
  853.   while (f.BufPos<f.BufEnd) and (f.Bufptr^[Temp]<>#10) Do
  854.    Begin
  855.      { search linefeed }
  856.      while (f.Bufptr^[Temp]<>#10) and (Temp<f.BufEnd) Do
  857.       inc(Temp);
  858.      { copy string. }
  859.      Move (f.Bufptr^[f.BufPos],p^,Temp-f.BufPos);
  860.      Inc(Longint(p),Temp-f.BufPos);
  861.      If pchar(p-1)^=#13 Then
  862.       dec(p);
  863.      { update f.BufPos }
  864.      f.BufPos:=Temp;
  865.      If Temp>=f.BufEnd Then
  866.       Begin
  867.         FileFunc(f.InOutFunc)(f);
  868.         Temp:=f.BufPos;
  869.       End
  870.    End;
  871.   p^:=#0;
  872. End;
  873.  
  874.  
  875. Procedure Read_Array(var f : TextRec;var s : array00);[Public,Alias:'READ_TEXT_PCHAR_AS_ARRAY'];
  876. var
  877.   p    : PChar;
  878.   Temp : byte;
  879. Begin
  880. { Delete the string }
  881.   s[0]:=#0;
  882.   If InOutRes <> 0 then exit;
  883.   p:=pchar(@s);
  884.   if not OpenInput(f) then
  885.    exit;
  886.   Temp:=f.BufPos;
  887.   while (f.BufPos<f.BufEnd) and (f.Bufptr^[Temp]<>#10) Do
  888.    Begin
  889.      { search linefeed }
  890.      while (f.Bufptr^[Temp]<>#10) and (Temp<f.BufEnd) Do
  891.       inc(Temp);
  892.      { copy string. }
  893.      Move (f.Bufptr^[f.BufPos],p^,Temp-f.BufPos);
  894.      Inc(Longint(p),Temp-f.BufPos);
  895.      If pchar(p-1)^=#13 Then
  896.       dec(p);
  897.      { update f.BufPos }
  898.      f.BufPos:=Temp;
  899.      If Temp>=f.BufEnd Then
  900.       Begin
  901.         FileFunc(f.InOutFunc)(f);
  902.         Temp:=f.BufPos;
  903.       End
  904.    End;
  905.   p^:=#0;
  906. End;
  907.  
  908.  
  909. {$ifdef useansistrings}
  910. Procedure Read_String(Maxlen : Longint;var f : TextRec;var s : AnsiString);[Public,Alias: 'READ_TEXT_ANSISTRING'];
  911. var
  912.   p    : PChar;
  913.   Temp : byte;
  914.   len  : Longint;
  915. Begin
  916. { Delete the string }
  917.   Decr_ansi_ref (S);
  918.   // We assign room for 1024 characters totally at random....
  919.   Pointer(s):=Pointer(NewAnsiString(1024));
  920.   If InOutRes <> 0 then exit;
  921.   p:=pointer(s);
  922.   if not OpenInput(f) then
  923.    exit;
  924.   Temp:=f.BufPos;
  925.   while (f.BufPos<f.BufEnd) and (f.Bufptr^[Temp]<>#10) Do
  926.    Begin
  927.      { search linefeed }
  928.      while (f.Bufptr^[Temp]<>#10) and (Temp<f.BufEnd) Do
  929.       inc(Temp);
  930.      { copy string. }
  931.      Move (f.Bufptr^[f.BufPos],p^,Temp-f.BufPos);
  932.      Inc(Longint(p),Temp-f.BufPos);
  933.      Inc(len,Temp-f.bufpos);
  934.      If pchar(p-1)^=#13 Then
  935.       dec(p);
  936.      { update f.BufPos }
  937.      f.BufPos:=Temp;
  938.      If Temp>=f.BufEnd Then
  939.       Begin
  940.         FileFunc(f.InOutFunc)(f);
  941.         Temp:=f.BufPos;
  942.       End
  943.    End;
  944.   p^:=#0;
  945.   PAnsiRec(Pointer(S)-FirstOff)^.Len:=len
  946. End;
  947. {$endif}
  948.  
  949.  
  950. Procedure Read_Longint(var f : TextRec;var l : Longint);[Public,Alias: 'READ_TEXT_LONGINT'];
  951. var
  952.   hs   : String;
  953.   code : Word;
  954.   base : longint;
  955. Begin
  956.   l:=0;
  957.   If InOutRes <> 0 then exit;
  958.   hs:='';
  959.   if not OpenInput(f) then
  960.    exit;
  961.   if IgnoreSpaces(f) and ReadSign(f,hs) and ReadBase(f,hs,Base) then
  962.    ReadNumeric(f,hs,Base);
  963.   Val(hs,l,code);
  964.   If code<>0 Then
  965.    HandleError(106);
  966. End;
  967.  
  968.  
  969. Procedure Read_Integer(var f : TextRec;var l : Integer);[Public,Alias: 'READ_TEXT_INTEGER'];
  970. var
  971.   ll : Longint;
  972. Begin
  973.   l:=0;
  974.   If InOutRes <> 0 then exit;
  975.   Read_Longint(f,ll);
  976.   If (ll<-32768) or (ll>32767) Then
  977.    HandleError(106);
  978.   l:=ll;
  979. End;
  980.  
  981.  
  982. Procedure Read_Word(var f : TextRec;var l : Word);[Public,Alias: 'READ_TEXT_WORD'];
  983. var
  984.   ll : Longint;
  985. Begin
  986.   l:=0;
  987.   If InOutRes <> 0 then exit;
  988.   Read_Longint(f,ll);
  989.   If (ll<0) or (ll>$ffff) Then
  990.    HandleError(106);
  991.   l:=ll;
  992. End;
  993.  
  994.  
  995. Procedure Read_Byte(var f : TextRec;var l : byte);[Public,Alias: 'READ_TEXT_BYTE'];
  996. var
  997.   ll : Longint;
  998. Begin
  999.   l:=0;
  1000.   If InOutRes <> 0 then exit;
  1001.   Read_Longint(f,ll);
  1002.   If (ll<0) or (ll>255) Then
  1003.    HandleError(106);
  1004.   l:=ll;
  1005. End;
  1006.  
  1007.  
  1008. Procedure Read_Shortint(var f : TextRec;var l : shortint);[Public,Alias: 'READ_TEXT_SHORTINT'];
  1009. var
  1010.    ll : Longint;
  1011. Begin
  1012.   l:=0;
  1013.   If InOutRes <> 0 then exit;
  1014.   Read_Longint(f,ll);
  1015.   If (ll<-128) or (ll>127) Then
  1016.    HandleError(106);
  1017.   l:=ll;
  1018. End;
  1019.  
  1020.  
  1021. Procedure Read_Cardinal(var f : TextRec;var l : cardinal);[Public,Alias: 'READ_TEXT_CARDINAL'];
  1022. var
  1023.   hs   : String;
  1024.   code : Word;
  1025.   base : longint;
  1026. Begin
  1027.   l:=0;
  1028.   If InOutRes <> 0 then exit;
  1029.   hs:='';
  1030.   if not OpenInput(f) then
  1031.    exit;
  1032.   if IgnoreSpaces(f) and ReadSign(f,hs) and ReadBase(f,hs,Base) then
  1033.    ReadNumeric(f,hs,Base);
  1034.   val(hs,l,code);
  1035.   If code<>0 Then
  1036.    HandleError(106);
  1037. End;
  1038.  
  1039.  
  1040. Procedure Read_Real(var f : TextRec;var d : Real);[Public,Alias: 'READ_TEXT_REAL'];
  1041. var
  1042.   hs   : String;
  1043.   code : Word;
  1044. Begin
  1045.   d:=0.0;
  1046.   If InOutRes <> 0 then exit;
  1047.   hs:='';
  1048.   if not OpenInput(f) then
  1049.    exit;
  1050.   if IgnoreSpaces(f) and ReadSign(f,hs) and ReadNumeric(f,hs,10) then
  1051.    begin
  1052.    { First check for a . }
  1053.      if (f.Bufptr^[f.BufPos]='.') and (f.BufPos<f.BufEnd) Then
  1054.       begin
  1055.         hs:=hs+'.';
  1056.         Inc(f.BufPos);
  1057.         If f.BufPos>=f.BufEnd Then
  1058.          FileFunc(f.InOutFunc)(f);
  1059.         ReadNumeric(f,hs,10);
  1060.       end;
  1061.    { Also when a point is found check for a E }
  1062.      if (f.Bufptr^[f.BufPos] in ['e','E']) and (f.BufPos<f.BufEnd) Then
  1063.       begin
  1064.         hs:=hs+'E';
  1065.         Inc(f.BufPos);
  1066.         If f.BufPos>=f.BufEnd Then
  1067.          FileFunc(f.InOutFunc)(f);
  1068.         if ReadSign(f,hs) then
  1069.          ReadNumeric(f,hs,10);
  1070.       end;
  1071.    end;
  1072.   val(hs,d,code);
  1073.   If code<>0 Then
  1074.    HandleError(106);
  1075. End;
  1076.  
  1077.  
  1078. {$ifdef SUPPORT_EXTENDED}
  1079. Procedure Read_Extended(var f : TextRec;var d : extended);[Public,Alias: 'READ_TEXT_EXTENDED'];
  1080. var
  1081.   hs   : String;
  1082.   code : Word;
  1083. Begin
  1084.   d:=0.0;
  1085.   If InOutRes <> 0 then exit;
  1086.   hs:='';
  1087.   if not OpenInput(f) then
  1088.    exit;
  1089.   if IgnoreSpaces(f) and ReadSign(f,hs) and ReadNumeric(f,hs,10) then
  1090.    begin
  1091.    { First check for a . }
  1092.      if (f.Bufptr^[f.BufPos]='.') and (f.BufPos<f.BufEnd) Then
  1093.       begin
  1094.         hs:=hs+'.';
  1095.         Inc(f.BufPos);
  1096.         If f.BufPos>=f.BufEnd Then
  1097.          FileFunc(f.InOutFunc)(f);
  1098.         ReadNumeric(f,hs,10);
  1099.       end;
  1100.    { Also when a point is found check for a E }
  1101.      if (f.Bufptr^[f.BufPos] in ['e','E']) and (f.BufPos<f.BufEnd) Then
  1102.       begin
  1103.         hs:=hs+'E';
  1104.         Inc(f.BufPos);
  1105.         If f.BufPos>=f.BufEnd Then
  1106.          FileFunc(f.InOutFunc)(f);
  1107.         if ReadSign(f,hs) then
  1108.          ReadNumeric(f,hs,10);
  1109.       end;
  1110.    end;
  1111.   val(hs,d,code);
  1112.   If code<>0 Then
  1113.    HandleError(106);
  1114. End;
  1115. {$endif SUPPORT_EXTENDED}
  1116.  
  1117.  
  1118. {$ifdef SUPPORT_COMP}
  1119. Procedure Read_Comp(var f : TextRec;var d : comp);[Public,Alias: 'READ_TEXT_COMP'];
  1120. var
  1121.   hs   : String;
  1122.   code : Word;
  1123. Begin
  1124.   d:=comp(0.0);
  1125.   If InOutRes <> 0 then exit;
  1126.   hs:='';
  1127.   if not OpenInput(f) then
  1128.    exit;
  1129.   if IgnoreSpaces(f) and ReadSign(f,hs) and ReadNumeric(f,hs,10) then
  1130.    begin
  1131.    { First check for a . }
  1132.      if (f.Bufptr^[f.BufPos]='.') and (f.BufPos<f.BufEnd) Then
  1133.       begin
  1134.         hs:=hs+'.';
  1135.         Inc(f.BufPos);
  1136.         If f.BufPos>=f.BufEnd Then
  1137.          FileFunc(f.InOutFunc)(f);
  1138.         ReadNumeric(f,hs,10);
  1139.       end;
  1140.    { Also when a point is found check for a E }
  1141.      if (f.Bufptr^[f.BufPos] in ['e','E']) and (f.BufPos<f.BufEnd) Then
  1142.       begin
  1143.         hs:=hs+'E';
  1144.         Inc(f.BufPos);
  1145.         If f.BufPos>=f.BufEnd Then
  1146.          FileFunc(f.InOutFunc)(f);
  1147.         if ReadSign(f,hs) then
  1148.          ReadNumeric(f,hs,10);
  1149.       end;
  1150.    end;
  1151.   val(hs,d,code);
  1152.   If code<>0 Then
  1153.    HandleError(106);
  1154. End;
  1155. {$endif SUPPORT_COMP}
  1156.  
  1157.  
  1158. {$ifdef VER0_99_5}
  1159. Procedure r(var f : TextRec);[Public,Alias: 'READLN_TEXT'];
  1160. Begin
  1161.   If InOutRes <> 0 then exit;
  1162.   if not OpenInput(f) then
  1163.    exit;
  1164.   while (f.BufPos<f.BufEnd) do
  1165.    begin
  1166.      inc(f.BufPos);
  1167.      if (f.BufPtr^[f.BufPos-1]=#10) then
  1168.       exit;
  1169.      If f.BufPos>=f.BufEnd Then
  1170.       FileFunc(f.InOutFunc)(f);
  1171.    end;
  1172. End;
  1173. {$endif VER0_99_5}
  1174.  
  1175.  
  1176. {*****************************************************************************
  1177.                                Initializing
  1178. *****************************************************************************}
  1179.  
  1180. procedure OpenStdIO(var f:text;mode:word;hdl:longint);
  1181. begin
  1182.   Assign(f,'');
  1183.   TextRec(f).Handle:=hdl;
  1184.   TextRec(f).Mode:=mode;
  1185.   TextRec(f).Closefunc:=@FileCloseFunc;
  1186.   case mode of
  1187.   fmInput : TextRec(f).InOutFunc:=@FileReadFunc;
  1188.  fmOutput : begin
  1189.               TextRec(f).InOutFunc:=@FileWriteFunc;
  1190.               TextRec(f).FlushFunc:=@FileWriteFunc;
  1191.             end;
  1192.   else
  1193.    HandleError(102);
  1194.   end;
  1195. end;
  1196.  
  1197.  
  1198. {
  1199.   $Log: text.inc,v $
  1200.   Revision 1.21  1998/08/17 22:42:17  michael
  1201.   + Flush on close only for output files cd ../inc
  1202.  
  1203.   Revision 1.20  1998/08/11 00:05:28  peter
  1204.     * $ifdef ver0_99_5 updates
  1205.  
  1206.   Revision 1.19  1998/07/30 13:26:16  michael
  1207.   + Added support for ErrorProc variable. All internal functions are required
  1208.     to call HandleError instead of runerror from now on.
  1209.     This is necessary for exception support.
  1210.  
  1211.   Revision 1.18  1998/07/29 21:44:35  michael
  1212.   + Implemented reading/writing of ansistrings
  1213.  
  1214.   Revision 1.17  1998/07/19 19:55:33  michael
  1215.   + fixed rename. Changed p to p^
  1216.  
  1217.   Revision 1.16  1998/07/10 11:02:40  peter
  1218.     * support_fixed, becuase fixed is not 100% yet for the m68k
  1219.  
  1220.   Revision 1.15  1998/07/06 15:56:43  michael
  1221.   Added length checking for string reading
  1222.  
  1223.   Revision 1.14  1998/07/02 12:14:56  carl
  1224.     + Each IOCheck routine now check InOutRes before, just like TP
  1225.  
  1226.   Revision 1.13  1998/07/01 15:30:00  peter
  1227.     * better readln/writeln
  1228.  
  1229.   Revision 1.12  1998/07/01 14:48:10  carl
  1230.     * bugfix of WRITE_TEXT_BOOLEAN , was not TP compatible
  1231.     + added explicit typecast in OpenText
  1232.  
  1233.   Revision 1.11  1998/06/25 09:44:22  daniel
  1234.   + RTLLITE directive to compile minimal RTL.
  1235.  
  1236.   Revision 1.10  1998/06/04 23:46:03  peter
  1237.     * comp,extended are only i386 added support_comp,support_extended
  1238.  
  1239.   Revision 1.9  1998/06/02 16:47:56  pierre
  1240.     * bug for boolean values greater than one fixed
  1241.  
  1242.   Revision 1.8  1998/05/31 14:14:54  peter
  1243.     * removed warnings using comp()
  1244.  
  1245.   Revision 1.7  1998/05/27 00:19:21  peter
  1246.     * fixed crt input
  1247.  
  1248.   Revision 1.6  1998/05/21 19:31:01  peter
  1249.     * objects compiles for linux
  1250.     + assign(pchar), assign(char), rename(pchar), rename(char)
  1251.     * fixed read_text_as_array
  1252.     + read_text_as_pchar which was not yet in the rtl
  1253.  
  1254.   Revision 1.5  1998/05/12 10:42:45  peter
  1255.     * moved getopts to inc/, all supported OS's need argc,argv exported
  1256.     + strpas, strlen are now exported in the systemunit
  1257.     * removed logs
  1258.     * removed $ifdef ver_above
  1259.  
  1260.   Revision 1.4  1998/04/07 22:40:46  florian
  1261.     * final fix of comp writing
  1262. }
  1263.